package Bio::Phylo::BioPrio::GreedySolution;
use strict;
use Bio::Phylo::BioPrio::SpeciesConservationMeasures;
use List::Util qw(first max maxstr min minstr reduce shuffle sum);

=head1 NAME

GreedySolution - Stores subsets of species corresponding to greedy solutions

=head1 DESCRIPTION

The simpler the instance of the NAP the more equally good solutions there 
will be to the NAP. This class permits these solutions to be stored in a 
efficient tree structure. 

No responsibility is taken for results produced by storing non-greedy
solutions in this data structure!!! In particulare the behaviour of 
get_pd_for_budget and get_expenditure may (probably will!) be incorrect.

=begin comment

 Type    : Constructor
 Title   : new
 Usage   : my $ss = SetSolution->new
 Function: Initializes a SetSolution object.
 Alias   :
 Returns : A SetSolution object.
 Args    : 

=end comment

=cut
sub new {
	
	my $class = shift;
    my $self;
    my $solution;
    
    #The species that could be added to this set in a greedy fashion
    $solution->{increment} = [];
    $solution->{decrement} = [];
    #Pointers to the sets that could be obtained in a greedy fashion
    $solution->{increment_ptr} = [];
    $solution->{decrement_ptr} = [];
    #The EPD of this set of species
    $solution->{epd} = 0;
    #The cost of conserving this set of species
    $solution->{cost} = 0;
    #The first set of species is an empty set
    $solution->{species} = [];
    #The id of the set
    $solution->{id} = 0;
    
    #A counter for the id
    $self->{set_id} = 1;
    
    #We store solutions in a hash by the species hash and by the id
    #that way they are easily accessed in either manner
    $self->{sets_hash}->{''} = $solution;
    $self->{sets_name}->{0} = $solution;
    
    bless $self, $class;
    return $self;
}

=begin comment

 Type    : Mutator
 Title   : add_transition
 Usage   : my $ss->add_transition(\@set,\@additions,\@pdgain,\@cost)
 Function: Adds a transition for an original set 
 Alias   :
 Returns : 1 if success, 0 if failure (@set is invalid)
 Args    : @set: the current set of species 
           @additions: the species that could be added in a greedy fashion
           @pdgain: the PD increase that each addition provides (equal unless 
           the costs are variable
           @cost: the cost of conserving each of the additions

=end comment

=cut
sub add_transition {
	#get the input
	my $self = shift;
	my @set = @{shift(@_)};
	my @additions = @{shift(@_)};
	my @pdgain = @{shift(@_)};
	my @cost = @{shift(@_)};
	
	my $setsize = scalar @set;

    #Get the hash key for this set
	my $src_hash = _get_hash_key(@set);
    
    #For each possible addition for this set we make appropriate entries
    for (my $index = 0; $index < @additions; $index++) {

		#Check the $src_hash key exists
		unless (exists $self->{sets_hash}->{$src_hash}) { return 0; }
		#Store the pointer to the solution
		my $src_solution = $self->{sets_hash}->{$src_hash};
		
    	#The destination hash key
		my $dest_hash = _get_hash_key($additions[$index],@set);
		my $dest_solution;
		#If the solution already exists get a pointer, 
		if (defined $self->{sets_hash}->{$dest_hash}) { 
			$dest_solution = $self->{sets_hash}->{$dest_hash} 
		#else store this pointer (setting the id makes it a pointer) 
		} else {
			$dest_solution->{id} = $self->{set_id}++; 
			$self->{sets_name}->{$dest_solution->{id}} = $dest_solution;
			$self->{sets_hash}->{$dest_hash} = $dest_solution;
		}
    
		#Set destination cost, epd and species set
		$dest_solution->{cost} = $src_solution->{cost} + $cost[$index];
		$dest_solution->{epd} = $src_solution->{epd} + $pdgain[$index]; 
		$dest_solution->{species} = [_unique_sorted_names_(@{$src_solution->{species}}, $additions[$index])]; 
		
		#Add the source to the destinations decrement pointers and species names
		push( @{$dest_solution->{decrement_ptr}}, $src_solution);
		push( @{$dest_solution->{decrement}}, $additions[$index]);
		
		#Add the destination the the sources increment pointsr
		push( @{$src_solution->{increment_ptr}}, $dest_solution);
		push( @{$src_solution->{increment}}, $additions[$index]);
    }
    #Delete any pre-computed stats -- they will need to be regenerated
    delete $self->{stats};
	return 1;
}

#Get the cost of a particular solution
sub get_solution_cost {
	my $self = shift;
	my $solution = $self->get_solution(@_);
	return $solution->{cost};
}

#Get the EPD of a particular solution
sub get_solution_epd {
	my $self = shift;
	my $solution = $self->get_solution(@_);
	return $solution->{epd};
}

#Get a solution, tries by id first if scalar argument (takes little time 
#as it simply checks the existence of a hash key) then gets a species set 
#hash and checks for its existence
sub get_solution {
	my $self = shift;
	
	#If scalar argument try matching the name first
	if (scalar @_ == 1) {
		if (defined $self->{sets_name}->{$_}) {
			return $self->{sets_name}->{$_};
		}
	} 
	
	#Match the hash key
	my $key = _get_hash_key(@_);
	if (defined $self->{sets_hash}->{$key}) {
		return $self->{sets_hash}->{$key};
	}
	
	#No matches
	return undef;
}

#Get all solutions
sub get_solutions_all {
	my $self = shift;
	return $self->get_solutions_n(-1);
}

#Get solutions of a given size, use size -1 for all
sub get_solutions_n {
	my $self = shift;
	my $n = shift;

	my @output;
	#store each solution
	my $sets = $self->{sets_hash};
	foreach my $setHash (keys %{$sets}) {
		if ($n == -1 || @{$sets->{$setHash}->{species}} == $n) {
			push(@output,$sets->{$setHash});
		}		
	}
	return @output;
	
}

#Get array of solutions of a given cost -- that is solutions where 
#partially conserving one or none of the species gives an optimal
#solution for the inputted cost.  
sub get_solutions_cost {
	my $self = shift;
	my $budget = shift;
	my @output;
	
	my $sets = $self->{sets_hash};
	
	my $index = 0;
	
	#For each set
	foreach my $setHash (keys %{$sets}) {
		
		my $cost = $sets->{$setHash}->{cost};
		#This solution must have a cost equal to or exceeding the budget
		next unless $cost >= $budget;
			
		my $included = 0;
		
		#If the zero solution met the budget criterion then we include it	
		if ($setHash eq '') { $included = 1; }		
		
		#Check each set from which this set can be obtained to check if the transition crossed the budget value
		foreach (@{$sets->{$setHash}->{decrement_ptr}}) {
			if ($_->{cost} < $budget) {
				$included++;
			} 
		}
		if ($included) { push(@output,$sets->{$setHash}); }
	}	
	return @output;
}

#Returns the pd for a particular budget
sub get_pd_for_budget {
	my $self = shift;
	my $budget = shift;
	my %points = $self->get_budget_pd_points();
	my @sorted = sort {$a <=> $b} keys %points;
	
	if ($budget >= $sorted[-1]) { return $points{$sorted[-1]}}
	
	for (my $index = 0; $index < @sorted-1; $index++) {
		if ($sorted[$index+1] > $budget) {
			return $points{$sorted[$index]} + 
				($budget-$sorted[$index])/($sorted[$index+1]-$sorted[$index]) *
				($points{$sorted[$index+1]} - $points{$sorted[$index]});
		}
	}
	return undef;
}

#Returns a hash, keys are costs, values are epd
sub get_budget_pd_points {
	my $self = shift;
	my %out;
	
	foreach (values %{$self->{sets_hash}}) {
		$out{$_->{cost}} = $_->{epd}; 
	}
	return %out;
	
} 

#Returns a hash with survival probabilities for each species, input is the solution name
sub get_expenditure {
	my $self = shift;
	my $name = shift;
	my %output;
	foreach (values %{$self->{sets_hash}}) {
		if ( $name eq $_->{generic_name} || ((defined $_->{name}) && ($name eq $_->{name})) ) {
			foreach ( @{$_->{species}} ) {
				$output{$_} = -1;
			}
			return %output;
		}
	}
	return undef;
}

#Get all set solution ids
sub get_solution_ids { return keys %{shift->{sets_hash}}; }


#Get the difference in species between two hashes
sub _hash_diff {
	
	my @set1 = _convert_hash_key($_[0]);
	my @set2 = _convert_hash_key($_[1]);
	
	return _set_diff(\@set1,\@set2);
}
	
#Get the difference in species between two lists 	
sub _set_diff {
	my @set1 = @{ shift(@_)};
	my @set2 = @{ shift(@_)};	
	my %hash;
	
	my @output;
	
	foreach (@set1) { $hash{$_} = 1; }
	foreach (@set2) {
		if ($hash{$_}) { delete $hash{$_}; }
		else { push (@output,$_); }
	}
	foreach (keys %hash) { push(@output,$_); } 
	if (scalar @output == 1) { return $output[0]; } else { return @output; }
}

#Convert the hash key to a list of species names
sub _convert_hash_key {
	my $key = shift;
	my @out = ($key =~ /[^ ]+/g);
	return @out;
}

#Convert a list of species names to a hash key
sub _get_hash_key {
	my @sorted = _unique_sorted_names_(@_);
	my $hash;
	$hash = "";
	foreach (@sorted) { $hash .= $_.' '}
	$hash = substr($hash,0,-1);
	return $hash;
}

#The minimum list index
sub get_min {
	my $self = shift;
	my %output;
	#Ensure the stats have been calculated
	unless (defined $self->{stats}) { $self->_calculate_stats($self->{sets_hash}->{''}); }
	
	#Get the minimum value for each species
	foreach (keys %{$self->{stats}}) {
		$output{$_} = min @{$self->{stats}->{$_}};
	}
	return %output;
}

#The minimum list index
sub get_max {
	my $self = shift;
	my %output;
	#Ensure the stats have been calculated
	unless (defined $self->{stats}) { $self->_calculate_stats($self->{sets_hash}->{''}); }
	
	#Get the minimum value for each species
	foreach (keys %{$self->{stats}}) {
		$output{$_} = max @{$self->{stats}->{$_}};
	}
	return %output;
}

#The minimum list index
sub get_mean {
	my $self = shift;
	my %output;
	#Ensure the stats have been calculated
	unless (defined $self->{stats}) { $self->_calculate_stats($self->{sets_hash}->{''}); }
	
	#Get the minimum value for each species
	foreach (keys %{$self->{stats}}) {
		$output{$_} = (sum @{$self->{stats}->{$_}})/(scalar @{$self->{stats}->{$_}});
	}
	return %output;
}

#Calculate stats
sub _calculate_stats {
	my $self = shift;
	my $solution = shift;
	#Add to the stats
	foreach (@{$solution->{increment}}) {
		unless (defined $self->{stats}->{$_}) {
			$self->{stats}->{$_} = [];
		}
		push(@{$self->{stats}->{$_}}, @{$solution->{species}} + 1);
	}
	foreach (@{$solution->{increment_ptr}}) {
		$self->_calculate_stats($_);
	}
}


=begin comment

 Type    : Internal function
 Title   : _unique_sorted_names_
 Usage   : $wx->_unique_sorted_names_;
 Function: Returns a list of the unique names, sorted alphabetically
 Returns : The sorted unique names
 Args    : The names

=end comment

=cut

sub _unique_sorted_names_ {
    my @names = @_;
    my @newnames;
    my %seen = ();
    foreach (@names) { unless ($seen{$_}++) { push(@newnames, $_) }; }
    return sort(@newnames);
}


1;